
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Macro Module -- Learning Binary Macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defparameter **skill-wrapper-map** nil)         ;skill-namespace (map id -> id)
(defparameter **new-macro-list** nil)            ;list of all newly-created macros
(defparameter **add-macros-to-skill-set?** nil)  ;  add new macros to skill-set immediately?

;;; parameters for tweaking macro-composition (for experimentation purposes)
(defparameter **enable-wrappers?** t)
(defparameter **get-skill-head-from-nonrecursive-side?** t)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  MACRO MODULE - interface functions:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; outputs the composed macro-intention
;; side-effects:  update Skill-Wrapper-Map
;;                add  Newly-defined macros to (either or both of) SLTM* **new-macro-list**)
(defun compose-binary-macro (intention-1 intention-2 
			     &key
			     operator-subgoaling?
			     int-1-terminal-in-tree?
			     int-2-terminal-in-tree?
			     wrap-non-terminals?
			     (enable-wrappers? **enable-wrappers?**)
			     (get-skill-head-from-nonrecursive-side?
			      **get-skill-head-from-nonrecursive-side?**)
			     )
  (let* ((macro-intention-1 (if (and enable-wrappers?
				     (or int-1-terminal-in-tree?
					 wrap-non-terminals?))
				(make-into-macro-intention intention-1)
				intention-1))
	 (macro-intention-2 (if (and enable-wrappers?
				     (or int-2-terminal-in-tree?
					 wrap-non-terminals?))
				(make-into-macro-intention intention-2)
				intention-2))
	 (h1 (intention-head macro-intention-1))
	 (c1 (intention-conditions macro-intention-1))
	 (e1 (intention-effects macro-intention-1))
	 (b1 (intention-bindings macro-intention-1))
	 (h2 (intention-head macro-intention-2))
	 (c2 (intention-conditions macro-intention-2))
	 (e2 (intention-effects macro-intention-2))
	 (b2 (intention-bindings macro-intention-2))
	 (c3 (compose-conditions c1 c2 e1 b1 b2))
	 (e3 (compose-effects e1 e2 b1 b2))
	 (b3x (compose-bindings b1 b2))  ;; Don't think this can be used (unless for non-recursive case)
	 (non-recursive? (non-recursive-composition? intention-1
						     intention-2
						     int-1-terminal-in-tree?
						     int-2-terminal-in-tree?
						     macro-intention-1
						     macro-intention-2
						     enable-wrappers?
						     operator-subgoaling?))
	 (h3 (cond (non-recursive? (new-macro-head b3x))
		   (operator-subgoaling? ; this method of setting the head will change as we figure things out
		    (if get-skill-head-from-nonrecursive-side?
			(intention-head macro-intention-2)
			(intention-head macro-intention-1)))
		   (t
		    (if get-skill-head-from-nonrecursive-side?
			(intention-head macro-intention-1)
			(intention-head macro-intention-2))
		    )))
	 (new-id (incf id-count*))
	 (macro-skill (make-sclause :head (variablize-constants h3)
				    :id new-id
				    :conditions  (variablize-constants-all c3)
				    :effects (variablize-constants-all e3)
				    :subskills (list (variablize-constants h1)
						     (variablize-constants h2))
				    :action nil))
	 (b3 (collect-variablized-constants-bindings macro-skill))
	 (macro-intention (make-intention :head h3
					  :id new-id
					  :bindings b3
					  :conditions c3
					  :effects e3
					  :subskills (list h1 h2)
					  :action nil)))
    (push macro-skill **new-macro-list**)
    (when **add-macros-to-skill-set?**
      (push macro-skill sltm*))
    macro-intention
    ))

(defun new-macro-head (bindings)
  (let* ((new-macro-name (gentemp "MACRO"))
	 (constants-from-bindings (loop for (var . val) in bindings
				       collect val))
	 (unique-constants (remove-duplicates constants-from-bindings)))
    (cons new-macro-name unique-constants)))

(defun non-recursive-composition? (intention-1
				   intention-2
				   int-1-terminal-in-tree?
				   int-2-terminal-in-tree?
				   macro-intention-1
				   macro-intention-2
				   enable-wrappers?
				   operator-subgoaling?)
  ;; how should this be deterimined?
  nil 					; always recursive for now?
  )


(defun init-skill-wrapper-map ()
  ;; initially implement as an alist
  (setf **skill-wrapper-map** nil)
  )

;;; This will be the main call to use in composition
;;;  It will check if intention is primitive,
;;;   and if so, will lookup entry (creating new entry when needed) in wrapper-id-map
;;;   and instantiate the wrapper intention to replace the original intention
;;;  If not primitive, simply returns intention itself
(defun make-into-macro-intention (intention &optional primitive-only?)
  (cond ((or (not primitive-only?)
	     (primitive-intention? intention))
	 (let* ((wrapper-id (find-wrapper-id-in-skill-namespace (intention-id intention)))
		(macro-skill (find-skill-from-id wrapper-id t)))
	   (create-intention macro-skill (intention-bindings intention))))
	(t intention)))

(defun isa-wrapper-id? (skill-id)
  (rassoc skill-id **skill-wrapper-map**)
  #+THE-LONG-WAY-AROUND
  (loop for (ignore . wrapper-id) in **skill-wrapper-map**
       thereis (eql skill-id wrapper-id)))

;; Modify spec for namespace map:  map (primitive-)skill-id -> macro-wrapper-id
;; If no wrapper id found, this function causes one to be created and stored
;;    (unless the skill-id itself is already a wrapper id)
(defun find-wrapper-id-in-skill-namespace (skill-id)
  (let ((assoc-pair (assoc skill-id **skill-wrapper-map**)))
    (cond (assoc-pair
	   (cdr assoc-pair))  ;; wrapper already defined for skill-id
	  ((isa-wrapper-id? skill-id)
	   skill-id)			; already a wrapper, just return it
	  (t
	   (let* ((wrapper-macro (create-unary-macro-wrapper skill-id))
		  (wrapper-macro-id (sclause-id wrapper-macro)))
	     (store-id-mapping-in-wrapper-map skill-id 
					      wrapper-macro-id)
	     wrapper-macro-id)))))

(defun store-id-mapping-in-wrapper-map (skill-id macro-id)
  (push (cons skill-id macro-id)
	**skill-wrapper-map**))


(defun create-unary-macro-wrapper (skill-id)
  (let* ((skill (find-skill-from-id skill-id))
	 (new-macro-name (gentemp "MACRO"))
	 (new-macro (copy-skill-with-new-name-and-id skill new-macro-name))
	 (percepts-forbidden-in-non-primitive-skills? t))
    (setf (sclause-subskills new-macro)
	  (sclause-head skill)) ;; RAB - shouldn't this be (list (sclause-head skill))?
    (setf (sclause-action new-macro) nil)
    (when percepts-forbidden-in-non-primitive-skills?
      (setf (sclause-percepts new-macro) nil))
    (push new-macro **new-macro-list**)
    (when **add-macros-to-skill-set?**
      (push new-macro sltm*))
    new-macro))


(defun find-skill-from-id (id &optional (search-new-macros-list-first? t))
  (loop with skill-list = (if search-new-macros-list-first?
			      (append **new-macro-list** sltm*)
			      sltm*)
     for skill in skill-list
     for skill-id = (sclause-id skill)
     when (eql id skill-id)
       do (return skill)))

(defun copy-skill-with-new-name-and-id (skill new-name)
  (make-sclause :head (cons new-name (cdr (sclause-head skill)))
		:id (incf id-count*)
		:percepts (sclause-percepts skill)
		:tests (sclause-tests skill)
		:conditions (sclause-conditions skill)
		:effects (sclause-effects skill)
		:subskills (sclause-subskills skill)
		:action (sclause-action skill)))

;; bindings from variablized constants
;; RAB - this is broken if a variable wasn't "variablized" from a constant - re-implmented
#+BROKEN
(defun collect-variablized-constants-bindings (macro-skill)
  (let* ((variables (collect-skill-variables macro-skill))
	 (bindings (loop for var in variables
			collect
			(cons var (constant-from-variable var)))))
    bindings))

(defun collect-skill-variables (macro-skill &optional (omit-negated-literal-vars? t))
  (remove-duplicates
   ;; collect-variables-from-list only does top-level, so may not be sufficient
   (append (collect-all-variables (sclause-head macro-skill) omit-negated-literal-vars?)
	   (collect-all-variables (sclause-conditions macro-skill) omit-negated-literal-vars?)
	   (collect-all-variables (sclause-effects macro-skill) omit-negated-literal-vars?)
	   (collect-all-variables (sclause-subskills macro-skill) omit-negated-literal-vars?))))

;; This descends into embedded lists to get all vars at every level
;;  Omits vars inside negations if omit-negated-literal-vars? is T
(defun collect-all-variables (list &optional (omit-negated-literal-vars? t))
  (cond ((null list)
	 nil)
	((eql (first list) 'not)
	 (if omit-negated-literal-vars?
	     nil
	     (collect-all-variables (cdr list) omit-negated-literal-vars?)))
	((variablep (first list))
	 (cons (first list)
	       (collect-all-variables (cdr list) omit-negated-literal-vars?)))
	((consp (first list))
	 (append (collect-all-variables (first list) omit-negated-literal-vars?)
		 (collect-all-variables (cdr list) omit-negated-literal-vars?)))
	(t ;;atom but not variable
	 (collect-all-variables (cdr list) omit-negated-literal-vars?))))

(defun constant-from-variable (var)
  ;;; strip "?" from start of symbol-name
  (read-from-string  (symbol-name var) t nil :start 1))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; OLD MACRO COMPOSITION CODE TO REUSE
;;;    [From file "macros-negin-2.lisp"]

;;; Compose Macro (from list of intentions and final-ground-goals)

;;;  NOTE: Strong assumption that each intention has "complete bindings"
;;;   i.e., bindings to completely ground its head, conditions, effects, and subskills

#|
;; Now returns a pair ( macro-skill merged-bindings ) 
;;   or an intention in the case of a segment with only one intention
(defun compose-macro (intention-list ground-goals)
  (cond ((null intention-list) nil)	; should never happen
	((= (length intention-list) 1)
	 ;; Handle case of single-intention -- kludge -- must check for type of entry when used
	 (first intention-list))
	(t (let* ((final-triple (pairwise-compose-intention-list intention-list))
		  (macro-conditions (remove-duplicates (first final-triple) :test #'equal))
		  (macro-effects (remove-duplicates (second final-triple) :test #'equal))
		  (macro-bindings (third final-triple))
		  (macro-subskills (make-subskill-list intention-list
						       macro-bindings))
					; replace this with head based on goals ?
		  (macro-head (create-macro-head ground-goals macro-bindings))
		  (macro-skill (create-macro-skill macro-head
						   (variablize-constants-all macro-conditions)
						   (variablize-constants-all macro-effects)
						   macro-subskills)))
	     (format t "~%Creating Macro: ~a" macro-head)
	     (print-skills (list macro-skill))
	     (format t "~%Merged-bindings: ~a" macro-bindings)
	     (list macro-skill
		   macro-bindings)))))

(defun create-macro-skill (head conditions effects subskills)
  (create-skill-clause (list head
			     :conditions conditions
			     :effects effects
			     :subskills subskills)))

;; making new skill head
(defun create-macro-head (ground-goals macro-bindings)
  (let* ((constants (collect-constants-from-literals ground-goals))
	 (unique-constants (remove-duplicates constants))
	 (unique-variables (variablize-constants-all unique-constants)))
    (cons (gentemp "SKILL")   ; gentemp is like gensym, but interns and ensures unique
	  unique-variables)))

|#

#|
;; Not Called
;; note this can create-duplicates if 2 different vars are bound to same value
(defun variablize-constant-bindings (bindings-list)
  (loop for (var . value) in bindings-list
       collect
       ; assume all values are constants
       (cons (variablize-constant value)
	     value)))
|#

(defun variablize-constant (constant)
  (read-from-string (format nil "?~a" constant)))

;; use this on all except bindings-lists
;;   It skips over first elements of lists if they are atoms (literal names)
(defun variablize-constants (form)
  (cond ((variablep form)
	 form)
	((null form) nil)
	((and (consp form)
	      (atom (car form)))
	 (cons (car form)
	       (variablize-constants-all (cdr form))))
	((consp form)
	 (cons (variablize-constants (car form))
	       (variablize-constants-all (cdr form))))
	(t 				;constant
	 (variablize-constant form))))

(defun variablize-constants-all (form)
  (cond ((variablep form)
	 form)
	((null form) nil)
	((consp form)
	 (cons (variablize-constants (car form))
	       (variablize-constants-all (cdr form))))
	(t 				;constant
	 (variablize-constant form))))

;; no longer called
(defun collect-variables-from-list (list)
  (loop for item in list
       when (variablep item)
       collect item))

(defun collect-constants-from-literals (literal-list)
  (loop for literal in literal-list
       append
       (collect-constants-from-literal literal)))

(defun collect-constants-from-literal (literal)
  (loop for item in (rest (if (eql (first literal) 'not)
			      (second literal) ; un-negated literal
			      literal))
       unless (or (consp item)
		  (variablep item))
       collect item))


;; make subskill list
(defun make-subskill-list (intention-list merged-bindings)
  (let ((ground-head-list 
	 (loop for intention in intention-list
	    collect
	      (subst-bindings (intention-bindings intention)
			      ;; (intention-calling-form intention)))))
			      (intention-head intention)))))
    (variablize-constants-all ground-head-list)))

#|
;; compose conditions and effects (using bindings)
(defun pairwise-compose-intention-list (intention-list)
  (when (< (length intention-list) 2)
    (error "Can't compose macro from less than 2 intentions"))
  (pairwise-compose-intention-triples
   (loop for intention in intention-list
	for bindings = (intention-bindings intention)
      collect (list (subst-bindings bindings (intention-conditions intention))
		    (subst-bindings bindings (intention-effects intention))
		    bindings))))

(defun pairwise-compose-intention-triples (triple-list)
  (loop with result-triple = (first triple-list)
       for triple in (rest triple-list)
       do
       (setf result-triple
	     (pairwise-compose result-triple
			       triple))
       finally
       (return result-triple)))
|#


;;; List Intention (triple)
;;
;;  ( <conditions> <effects> <bindings> )

;;  Compose ( c1 e1 b1 )
;;      and ( c2 e2 s2 )
;;   as
;;      ( (compose-conditions c1 c2 e1 b1 b2)
;;        (compose-effects e1 e2 b1 b2)
;;        (compose-bindings b1 b2) )


#|
(defun pairwise-compose (list-intention-1 list-intention-2)
  (let* ((c1 (first list-intention-1))
	 (e1 (second list-intention-1))
	 (b1 (third list-intention-1))
	 (c2 (first list-intention-2))
	 (e2 (second list-intention-2))
	 (b2 (third list-intention-2)))
    (list (compose-conditions c1 c2 e1 b1 b2)
	  (compose-effects e1 e2 b1 b2)
	  (compose-bindings b1 b2))))
|#

(defun compose-bindings (bindings-1 bindings-2)
  (append bindings-1 bindings-2))


; COMPOSE-CONDITIONS inputs the conditions of one skill (FIRST-CONDS), 
; the conditions of another skill (SECOND-CONDS), the effects of the
; first skill (FIRST-EFFECTS), and a set of shared variable bindings. 
; It returns composed conditions that are the first conditions plus 
; the second conditions, except for removing any positive conditions 
; made true by positive first effects and removing any negative 
; conditions made true by negated first effects. 
#+OLD
(defun compose-conditions (first-conds second-conds first-effects 
			   first-bindings second-bindings)
  (setq first-conds (subst-bindings first-bindings first-conds))
  (setq second-conds (subst-bindings second-bindings second-conds))
  (setq first-effects (subst-bindings first-bindings first-effects))
  (let ((result first-conds)
	(merged-bindings (append first-bindings second-bindings)))
    (do ((snext (car second-conds) (car second-conds)))
	((null second-conds)
	 result)
      (cond ((and (eq (car snext) 'not)
		  (matches-any-not snext first-effects)) nil)
	    ((member snext first-effects :test 'equal) nil)
	    (t (push snext result)))
      (pop second-conds))))

; COMPOSE-EFFECTS inputs the effects of one skill (FIRST-EFFECTS), 
; the effects of another skill (SECOND-EFFECTS), and a set of shared
; variable bindings. It returns composed conditions that are the 
; second effects plus the first effects, except for removing any 
; positive effects undone by negated second effects and removing 
; any negative effects undone by positive second effects. 

;; The effects of the macro should be the union of the
;; both skills' effects minus those effects of the left skill that are
;; made untrue by the effects of the right skill. -Pat
#+OLD
(defun compose-effects (first-effects second-effects first-bindings second-bindings)
  (setq first-effects (subst-bindings first-bindings first-effects))
  (setq second-effects (subst-bindings second-bindings second-effects))
  (let ((result second-effects)
	(merged-bindings (append first-bindings second-bindings)))
    (do ((fnext (car first-effects) (car first-effects)))
	((null first-effects)
	 result)
      (cond ((and (eq (car fnext) 'not)
		  (matches-any-pos fnext second-effects)) nil)
	    ((matches-any-neg fnext second-effects) nil)
	    (t (push fnext result)))
      (pop first-effects))))

; MATCHES-ANY-NEG inputs a negated element (e.g., (not (on ?X B)))
; and a list of positive and/or negated conditions. It returs T if 
; the negated element matches any of the negated conditions (e.g., 
; (not (on ?Y ?Z)) and returns NIL otherwise. 

(defun matches-any-not (neg conds) 
  (cond ((null conds) nil)
	((and (eq (caar conds) 'not)
	      (unify (cadr neg) (cadar conds))) t)
	(t (matches-any-not neg (cdr conds)))))

; MATCHES-ANY-POS inputs a negated element (e.g., (not (on ?X B)))
; and a list of positive and/or negated elements. It returs T if any 
; positive elements (e.g., (on A B)) matches the negated element and 
; returns NIL otherwise. 

(defun matches-any-pos (neg conds) 
  (cond ((null conds) nil)
	((and (not (eq (caar conds) 'not))
	      (unify (car conds) (cadr neg))) t)
	(t (matches-any-pos neg (cdr conds)))))

; MATCHES-ANY-NEG inputs a positive literal (e.g., (on A B)) and 
; a list of positive and/or negated conditions. It returs T if 
; the positive literal matches the body of any negated condition 
; (e.g., (not (on ?X B)) and returns NIL otherwise. 

(defun matches-any-neg (pos conds)
  (cond ((null conds) nil)
	((and (eq (caar conds) 'not)
	      (unify pos (cadar conds))) t)
	(t (matches-any-neg pos (cdr conds)))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|
DATA STRUCTURES
  1. MACRO-SKILLS
       Macros created by the module will always be unary or binary
               (ie have exactly 1 or 2 subskills)
       Unary macros have 1 (primitive) subskill, and serve as a
             wrapper for that subskill,

              allowing introduction of a new name (to support recursion).
       Binary macros will have 2 subskills, at least one of which
will be a macro.
       Binary macros will get their skill-name from either the 1st or
second subskill,
               depending on whether there was operator subgoaling or not.
  2. SKILL NAMESPACE
     [ primitive-skill-name  -> macro-skill-name ]
     There will be a Skill Namespace that maps primitive skill names
to macro skill names.
     This records the wrapper names for unary macros.
           Naming of new macros will be as follows:
                  Unary macros (wrappers) will get a GENSYM'd name (and get
                        recorded in the namespace under the subskill's name)
                  Binary macros will get their name
                         from the 1st subskill if operator subgoaling occurred,
                         otherwise the 2nd subskill.





INIT-SKILL-NAMESPACE
   Sets **skill-name-space** to an Empty Namespace map  (not entries)

LOOKUP-IN-SKILL-NAMESPACE
   INPUT
     Intention   whose name is to be looked-up
         [need intention, both to check if it's primitive,
             and to create a (unary) wrapper macro if needed]
   OUTPUT
     Macro-name associated with skill-name
         (either found by lookup, or created and stored as new entry)
   SIDE-EFFECT
     If no entry was found for Skill-name, then
       1. Then a new macro-skill-name is GENSYMed (GENTEMPed)
       2. A new Unary Macro

       and is recorded with skill-name as key, and new macro-skill-name as value


****************************************************************

ISSUES:
 1. abstracting bindings to get variables for skill?
        [we had a hack in the original macro-composition code,
           that simply turned all constants into variables, as I recall]
        Testing may indicate that this "solution" is not sufficiently general.
          [just flagging the issue to be alert to it moving forward]

 2. Do all skills with same name have to have congruent Skill-Heads
(ie same arguments)

      Conceptual bug??
         If composed macro-intention gets its skill name from only 1
of the input intentions,
           Does that constrain the variables in the new Skill-Head ??
           In general, won't macro-composition create a "combined
variable list"
               (different from either of the sub-intentions) ??
|#